HPAVC/HPAVC CD-ROM.iso/pc/MYMUD21.ZIP/MMUD21.ZIP/SOURCE/SOURCE.ZIP/LOWLEVEL.PAS

Pascal/Delphi Source File | 1995-01-21 | 26.7 KB | 980 lines

{$I COPYRGHT.INC}

(*---------------------------------------------------------------------------*
   General LowLevel routines
 *---------------------------------------------------------------------------*)

Unit LowLevel;
Interface
Uses Dos,
     MyIO,    { ReadKey -> Get password function! }
     Misc,
     Header,
     Multi,
     BIN_DB;

(*---------------------------------------------------------------------------*
  Move an object to the contents chain of an other object.
 *---------------------------------------------------------------------------*)
Procedure MoveTo(ObjNr,ToObj : Integer);

(*---------------------------------------------------------------------------*
  Handle DRONE's. Exitnr is not used at this moment. Current.room should
  containt the TO room. FromRoom should contain the current location.
 *---------------------------------------------------------------------------*)

Procedure HandleDrones( ExitNr   : Integer;
                        Current  : ContextType;
                        FromRoom : Integer);

(*---------------------------------------------------------------------------*
  Unlink an object.
 *---------------------------------------------------------------------------*)
Procedure Unlink(ObjNr : Integer);


(*---------------------------------------------------------------------------*
  Check if a string is part of a ; delimited list
 *---------------------------------------------------------------------------*)
Function CheckName(S,List : String):Boolean;

(*---------------------------------------------------------------------------*
  Check if a word is exact matched within a string.
 *---------------------------------------------------------------------------*)
Function ExactWordMatch(FWord,Line : String):Boolean;
Function FussyWordMatch(FWord,Line : String):Boolean;
(*---------------------------------------------------------------------------*
  Find a word in a ; delimited list
 *---------------------------------------------------------------------------*)
Function CheckNameList(FWord,Line : String):Boolean;

(*---------------------------------------------------------------------------*
  Find an Item by name in a object list
 *---------------------------------------------------------------------------*)
Function FindItem(StartRec : Integer;Item : String):Integer;
Function FussyFindItem(StartRec : Integer;Item : String):Integer;

(*---------------------------------------------------------------------------*
  Check if an object is in the current location
 *---------------------------------------------------------------------------*)
Function ObjectIsHere(Current : ContextType;Item : String):Integer;

(*---------------------------------------------------------------------------*
  Show a list of items in a contents list
 *---------------------------------------------------------------------------*)
Procedure List_Things(StartRec : Integer;ShowAll : Boolean);

(*---------------------------------------------------------------------------*
  Show all the players in a contents list
 *---------------------------------------------------------------------------*)
Procedure List_Players(Current : ContextType;StartRec : Integer);

(*---------------------------------------------------------------------------*
  Find an object by name. Return the object nr.
 *---------------------------------------------------------------------------*)
Function Str2ObjNr(Var Current : ContextType;InpStr : String):Integer;
Function FussyStr2ObjNr(Var Current : ContextType;InpStr : String):Integer;

(*---------------------------------------------------------------------------*
  Show a file on screen. Paginated
 *---------------------------------------------------------------------------*)
Procedure ShowFile(FileName : ComStr);

(*---------------------------------------------------------------------------*
  Translate the objectnames in an expression to ObjectNumbers
 *---------------------------------------------------------------------------*)
Procedure TranslateExpression(Current : ContextType;Var Expr : String);

(*---------------------------------------------------------------------------*
 Check if a user finds a pennie
 *---------------------------------------------------------------------------*)
Procedure Generate_Pennies(Current : ContextType);


(*---------------------------------------------------------------------------*
   Login. Checks name, creates new users.
 *---------------------------------------------------------------------------*)
Type LogInTypes = ( NoLogin,NormalLogin,NewLogin,AskedQUIT,
                    ShowWho,ShowVersion);
Function LogIn(Var Current : ContextType):LogInTypes;

(*---------------------------------------------------------------------------*
  Create a new object.
 *---------------------------------------------------------------------------*)
Function CreateNewObject(Var Current : ContextType;
                             ObjType : Byte;
                             Name    : String;
                             Cost    : Integer):Integer;

Implementation

(*---------------------------------------------------------------------------*)
Function Str2ObjNr(Var Current : ContextType;InpStr : String):Integer;
Var Err   : Integer;
    ObjNr : Integer;
Begin
InpStr:=UpStr(InpStr);
If InpStr=Current.PlayerName
   Then Begin
        Str2ObjNr:=Current.Player;
        Exit;
        End;

If InpStr='ME'
   Then Begin
        Str2ObjNr:=Current.Player;
        Exit;
        End;

If InpStr='HERE'
   Then Begin
        Str2ObjNr:=Current.Room;
        Exit;
        End;

If InpStr[1]='#'
   Then Begin
        Delete(InpStr,1,1);
        Val(InpStr,Objnr,Err);
        If (Err<>0) Or (Not Current.DB.ExistObj(ObjNr))
           Then Begin
                My_WriteLn('Illegal objectnumber.');
                ObjNr:=NOTHING;
                End;
        End
   Else Begin
        Current.DB.ReadObj(Current.Player);
        ObjNr:=FindItem(Current.DB.ObjRec.Contents,InpStr);

        If ObjNr=NOTHING
           Then Begin
                Current.DB.ReadObj(Current.Room);
                ObjNr:=FindItem(Current.DB.ObjRec.Contents,InpStr);
                End;

        If ObjNr=NOTHING
           Then ObjNr:=FindItem(Current.DB.ObjRec.Exits,InpStr);

        If (ObjNR=NOTHING) And
           CheckNameList(InpStr,Current.DB.ObjRec.Name)
           Then ObjNr:=Current.Room;

        End;
Str2ObjNr:=ObjNr;
End;

Function FussyStr2ObjNr(Var Current : ContextType;InpStr : String):Integer;
Var Err   : Integer;
    ObjNr : Integer;
Begin
InpStr:=UpStr(InpStr);
Current.DB.ReadObj(Current.Player);
ObjNr:=FussyFindItem(Current.DB.ObjRec.Contents,InpStr);

If ObjNr=NOTHING
  Then Begin
       Current.DB.ReadObj(Current.Room);
       ObjNr:=FussyFindItem(Current.DB.ObjRec.Contents,InpStr);
       End;

If ObjNr=NOTHING
  Then ObjNr:=FussyFindItem(Current.DB.ObjRec.Exits,InpStr);
FussyStr2ObjNr:=ObjNr;
End;


(*---------------------------------------------------------------------------*)
Procedure MoveTo(ObjNr,ToObj : Integer);
Var Dum    : Database;
    ORec   : ObjRecord;
    From   : Integer;
    CurrNr : Integer;
Begin
Lock('Move To '+Dum.Name);

Dum.Init;
Dum.ReadObj(ObjNr);
ORec:=Dum.ObjRec;
From:=Dum.ObjRec.Location;
Dum.ReadObj(From);


{ Unlink record }
If Dum.ObjRec.Contents=ObjNr                { If obj is first in chain }
   Then Begin
        Dum.ObjRec.Contents:=ORec.Next;     { Unlink object            }
        Dum.UpdateObj(From);                { Save source location     }
        End
   Else Begin
        CurrNr:=Dum.ObjRec.Contents;
        Dum.ReadObj(CurrNr);                { Read first item in chain }
        While (Dum.ObjRec.Next<>NOTHING) And
              (Dum.ObjRec.Next<>ObjNr) Do     { Search for the object    }
          Begin
          CurrNr:=Dum.ObjRec.Next;
          Dum.ReadObj(Dum.ObjRec.Next);
          End;
{**}    Dum.ObjRec.Next:=ORec.Next;         { Unlink the object        }
        Dum.UpdateObj(CurrNr);              { Update source record     }
        End;

{ Link in }

Dum.ReadObj(ToObj);
CurrNr:=ToObj;
If Dum.ObjRec.Contents=NOTHING
   Then Dum.ObjRec.Contents:=ObjNr
   Else Begin
        CurrNr:=Dum.ObjRec.Contents;
        Dum.ReadObj(CurrNr);
        While Dum.ObjRec.Next<>NOTHING Do
          Begin
          CurrNr:=Dum.ObjRec.Next;
          Dum.ReadObj(CurrNr);
          End;
        Dum.ObjRec.Next:=ObjNr;
        End;
Dum.UpdateObj(CurrNr);

ORec.Location:=ToObj;
ORec.Next:=NOTHING;
Dum.ObjRec:=ORec;               { Prepare object for saving              }
Dum.UpdateObj(ObjNr);           { Save object                            }
Dum.Final;

Unlock;
End;

(*--------------------------------------------------------------------------*)
Procedure HandleDrones( ExitNr   : Integer;
                        Current  : ContextType;
                        FromRoom : Integer);
Var Dum    : Database;
    GetRec : Integer;
Begin
Dum.Init;
Dum.ReadObj(FromRoom);
If Dum.ObjRec.Contents=NOTHING
   Then Begin
        Dum.Final;
        Exit;
        End;

GetRec:=Dum.ObjRec.Contents;

While GetRec<>NOTHING Do
 Begin
 Dum.ReadObj(GetRec);

 If (Dum.ObjRec.ObjType = Drone_Type) And
    Dum.IsOwnedBy(Current.Player)
    Then Begin
         GeneralRemarkToAllHere(Dum.Name+' follows '+Current.Playername);
         MoveTo(Dum.CObjNr,Current.Room);
         End;
 GetRec:=Dum.ObjRec.Next;
 End;
Dum.Final;
End;


(*---------------------------------------------------------------------------*)
Procedure Unlink(ObjNr : Integer);
Var Dum    : Database;
    ORec   : ObjRecord;
    From   : Integer;
    CurrNr : Integer;
Begin
Lock('Unlink ');

Dum.Init;
Dum.ReadObj(ObjNr);
ORec:=Dum.ObjRec;

From:=Dum.ObjRec.Location;
Dum.ReadObj(From);

{ Unlink record }
If Dum.ObjRec.Contents=ObjNr                { If obj is first in chain }
   Then Begin
        Dum.ObjRec.Contents:=ORec.Next;     { Unlink object            }
        Dum.UpdateObj(From);                { Save source location     }
        End
   Else Begin
        CurrNr:=Dum.ObjRec.Contents;
        Dum.ReadObj(Dum.ObjRec.Contents);   { Read first item in chain }
        While Dum.ObjRec.Next<>ObjNr Do     { Search for the object    }
          Begin
          CurrNr:=Dum.ObjRec.Next;
          Dum.ReadObj(Dum.ObjRec.Next);
          End;
        Dum.ObjRec.Next:=ORec.Next;         { Unlink the object        }
        Dum.UpdateObj(CurrNr);              { Update source record     }
        End;
Dum.Final;
Unlock;
End;


(*---------------------------------------------------------------------------*)
Function CheckName(S,List : String):Boolean;
Var Tok : String;
    C   : Byte;
Begin
For C:=1 To Length(S) do
 S[C]:=Upcase(S[C]);
For C:=1 To Length(List) Do
 List[C]:=UpCase(List[C]);

Repeat
 C:=1;
 Tok:='';

 While (C<=Length(List)) And (List[C]<>';') Do
  Begin
  Tok:=Tok+List[C];
  Inc(C);
  End;
 Delete(List,1,C);
 Tok:=CleanUp(Tok);
Until (Tok='') Or (Tok=S);
CheckName:=Tok=S;
End;

(*---------------------------------------------------------------------------*)
Procedure List_Things(StartRec : Integer;ShowAll : Boolean);
Var Tmp    : Database;
    GetRec : Integer;
    Found  : Boolean;
    Count  : Word;
Begin
Tmp.Init;
Found:=False;
GetRec:=StartRec;
Count:=0;
My_Write('You see ');
While (Not Found) and (Tmp.ObjRec.Next<>NOTHING) Do
 Begin
 Tmp.ReadObj(GetRec);
 If (ShowAll or Tmp.IsThing) And
    (Not Tmp.IsInvisible)
    Then Begin
         If Count=0
            Then My_WriteLn('');
         If Tmp.IsForSale
            Then My_WriteLn(' '+Tmp.Name+' ('+Nr2Str(Tmp.ObjRec.Pennies)+'p).')
            Else My_WriteLn(' '+Tmp.Name);
         Inc(Count);
         End;
 GetRec:=Tmp.ObjRec.Next;
 End;
If Count=0
   Then My_WriteLn('nothing special.');
Tmp.Final;
End;

(*---------------------------------------------------------------------------*)
Procedure List_Players(Current : ContextType;StartRec : Integer);
Var Tmp    : Database;
    GetRec : Integer;
    Found  : Boolean;
    Count  : Word;
Begin
Tmp.Init;
Found:=False;
GetRec:=StartRec;
Count:=0;
While (Not Found) and (GetRec<>NOTHING) Do
 Begin
 Tmp.ReadObj(GetRec);
 If (Tmp.IsPlayer Or Tmp.IsDrone) and
    (Not Tmp.IsInvisible) And
    (Tmp.CObjNr<>Current.Player)
    Then Begin
         If Tmp.IsDrone
            Then Begin
                 If Tmp.IsOwnedBy(Current.Player)
                    Then My_WriteLn(Tmp.name+' is here.')
                    Else My_WriteLn('You see '+Tmp.Name);
                 End
            Else Begin
                 If IsAlive(Tmp.CObjNr) Or IsAlive(Tmp.ObjRec.Owner)
                    Then My_WriteLn(Tmp.Name+' is here.');
                 End;
         Inc(Count);
         End;
 GetRec:=Tmp.ObjRec.Next;
 End;
Tmp.Final;
End;

(*---------------------------------------------------------------------------*)
Function FindItem(StartRec : Integer;Item : String):Integer;
Var Tmp    : Database;
    GetRec : Integer;
    Found  : Boolean;
Begin
Tmp.Init;
Found:=False;
GetRec:=StartRec;
While (Not Found) and (GetRec<>NOTHING) Do
 Begin
 Tmp.ReadObj(GetRec);
 If ExactWordMatch(Item,Tmp.ObjRec.Name) Or
    CheckNameList(Item,Tmp.ObjRec.Name)
    Then Found:=True
    Else GetRec:=Tmp.ObjRec.Next;
 End;
Tmp.Final;
If Found
   Then FindItem:=GetRec
   Else FindItem:=NOTHING;
End;

Function FussyFindItem(StartRec : Integer;Item : String):Integer;
Var Tmp    : Database;
    GetRec : Integer;
    Found  : Boolean;
Begin
Tmp.Init;
Found:=False;
GetRec:=StartRec;
While (Not Found) and (GetRec<>NOTHING) Do
 Begin
 Tmp.ReadObj(GetRec);
 If FussyWordMatch(Item,Tmp.ObjRec.Name) Or
    CheckNameList(Item,Tmp.ObjRec.Name)
    Then Found:=True
    Else GetRec:=Tmp.ObjRec.Next;
 End;
Tmp.Final;
If Found
   Then FussyFindItem:=GetRec
   Else FussyFindItem:=NOTHING;
End;

(*---------------------------------------------------------------------------*)
Function ObjectIsHere(Current : ContextType;Item : String):Integer;
Var Nr : Integer;
Begin
Nr:=NOTHING;
Current.DB.ReadObj(Current.Room);
Nr:=FindItem(Current.DB.ObjRec.Contents,Item);
If Nr=NOTHING
   Then Nr:=FindItem(Current.DB.ObjRec.Exits,Item);
If Nr=NOTHING
   Then Nr:=FussyFindItem(Current.DB.ObjRec.Contents,Item);

If Nr=NOTHING
   Then Begin
        Current.DB.ReadObj(Current.Player);
        Nr:=FindItem(Current.DB.ObjRec.Contents,Item);
        End;
If Nr=NOTHING
   Then Nr:=FussyFindItem(Current.DB.ObjRec.Contents,Item);
ObjectIsHere:=Nr;
End;

(*---------------------------------------------------------------------------*)
Procedure ShowFile(FileName : ComStr);
Var Inp       : Text;
    Line      : String;
    LineCount : Byte;
    Dum       : Char;
Begin
Assign(Inp,FileName);
Reset(Inp);
If IoResult<>0
   Then Exit;
LineCount:=0;
While Not Eof(Inp) Do
 Begin
 ReadLn(Inp,Line);
 My_WriteLn(Line);
 Inc(LineCount);
 If LineCount=22
    Then Begin
         My_Write('--- Press KEY to continue.. ---');
         Dum:=My_ReadKey;
         My_Write(#13);My_ClrEol;
         LineCount:=0;
         End;
 End;
Close(Inp);
End;

(*---------------------------------------------------------------------------*)

Function ExactWordMatch(FWord,Line : String):Boolean;
Var P       : Byte;
    Temp    : String;
Begin
ExactWordMatch:=False;
FWord:=UpStr(FWorD);
Line:=UpStr(Line);
Temp:='';

Repeat
  P:=Pos(';',Line);
  If P=0 Then P:=Length(Line)+1;
  If (Line<>'') And (P>0)
     Then Begin
          Temp:=Copy(Line,1,P-1);
          Delete(Line,1,P);
          If Temp=FWord
             Then Begin
                  ExactWordMatch:=True;
                  Exit;
                  End;
          End;
Until (P=0) Or (Line='');
End;


Function FussyWordMatch(FWord,Line : String):Boolean;
Var P       : Byte;
    CC1,CC2 : Char;
Begin
FussyWordMatch:=False;
FWord:=UpStr(FWorD);
Line:=UpStr(Line);
P:=Pos(FWord,Line);
If P=0
   Then Exit;
If P=1
   Then CC1:=' '
   Else CC1:=Line[P-1];
If (P+Length(FWord)-1)=Length(Line)
   Then CC2:=' '
   Else CC2:=Line[P+Length(FWord)];

FussyWordMatch:=(Not (Upcase(CC1) in ['A'..'Z','0'..'9'])) And
                (Not (Upcase(CC2) in ['A'..'Z','0'..'9']));
End;

(*---------------------------------------------------------------------------*)
Function RegMatch(Expr,Match : String):Boolean;
Var StarPos : Byte;
Begin
RegMatch:=False;
StarPos:=Pos('*',Expr);
MemMatch:='';
If StarPos>0
   Then Begin
        Expr:=Copy(Expr,1,StarPos-1);
        If Pos(Expr,Match)=1
           Then Begin
                RegMatch:=True;
                MemMatch:=LastSentence;
                Delete(MemMatch,1,Length(Expr));
                Exit;
                End;
        End
   Else RegMatch:=Expr=Match;
End;


Function CheckNameList(FWord,Line : String):Boolean;
Var Check : String;
    Stop  : Boolean;
Begin
FWord:=CleanUp(FWord);
Line:=UpStr(Line);
Check:='';
Stop:=False;
While (Line<>'') and (Not Stop) Do
 Begin
 If Pos(';',Line)>0
    Then Check:=Copy(Line,1,Pos(';',Line)-1)
    Else Begin
         Check:=Line;
         Line:='';
         End;
 Delete(Line,1,Length(Check)+1);
 Check:=CleanUp(Check);
 Stop:=RegMatch(Check,FWord);
 End;
CheckNameList:=Stop;
End;


(*---------------------------------------------------------------------------*)
Function GetPassword:String;
Var Tmp     : String;
    Key     : Char;
    GotChar : Boolean;
Begin
Tmp:='';
Repeat
  GotChar:=False;
  Repeat
   If My_KeyPressed
      Then Begin
           Key:=Upcase(My_ReadKey);
           If Key=#00
              Then Key:=My_ReadKey
              Else GotChar:=True;
           End;
  Until GotChar;
  Case Key of
   #8 : Begin
        If Tmp<>''
           Then Begin
                Dec(Tmp[0]);
                My_Write(#8' '#8);
                End;
        End;
   #13: Begin
        GetPassword:=Tmp;
        Exit;
        End;
   Else Begin
        If Key>=' '
           Then Begin
                Tmp:=Tmp+Key;
                My_Write('#');
                End
           Else My_Write(#7);
        End;
  End; {Case}
Until False;
End;


(*---------------------------------------------------------------------------*)
Function CreateNewObject(Var Current : ContextType;
                             ObjType : Byte;
                             Name    : String;
                             Cost    : Integer):Integer;
Var Temp  : ObjRecord;
    RecNr : Integer;
    Dum   : Database;
Begin
CreateNewObject:=NOTHING;
Lock('New object');
FillChar(Temp,SizeOf(Temp),#00);

Temp.Name:=Name;
Temp.Owner:=Current.Player;
If Not (ObjType in [Room_Type,Exit_Type])
   Then Temp.Location:=Current.Player
   Else Temp.Location:=NOTHING;

Temp.Pennies:=(Cost Div 2)-1;
Temp.GenFlags:=0;

Temp.ObjType:=ObjType;
Temp.Exits:=NOTHING;
Temp.Contents:=NOTHING;
Temp.Next:=NOTHING;
Temp.Attr_Flags:=Chown_Ok_Flag;

Current.DB.ReadObj(Current.Player);
If ObjType<>Room_Type
   Then Begin
        If (Current.DB.IsOwner(Current.Room)) Or
           (Current.Level>=Wizard_Level)
           Then Temp.Exits:=Current.Room
           Else Temp.Exits:=Current.DB.ObjRec.Exits;
        End;


Current.DB.ObjRec:=Temp;
RecNr:=Current.DB.AddObj;
Current.DB.ReadObj(RecNr);

Dum.Init;
Dum.ReadObj(Current.Player);
If Not Dum.LevelOk(Wizard_Level)
   Then Dec(Dum.ObjRec.Pennies,Cost);
If (ObjType=Thing_type) Or (ObjType=Drone_Type)
   Then Begin
        Current.DB.ObjRec.Next:=Dum.ObjRec.Contents;
        Dum.ObjRec.Contents:=RecNr;
        End;
Dum.UpdateObj(Current.Player);
Current.DB.UpdateObj(RecNr);

Dum.Final;
Current.DB.Final;
Current.DB.Init;

Unlock;
CreateNewObject:=RecNr;
End;


(*---------------------------------------------------------------------------*)

Const SpecialTypes : Array[1..5] of String [10]
                   = ('GAME','WHO','HELP','QUIT','INFO');

Function FindSpec(S : String):Byte;
Var Tmp : Byte;
Begin
S:=UpStr(S);
Tmp:=5;
While (Tmp>0) And (S<>SpecialTypes[Tmp]) Do
 Dec(Tmp);
FindSpec:=Tmp;
End;


Function LogIn(Var Current : ContextType):LogInTypes;
Var PassWord : PassString;
    PassCount: Byte;
    Ok       : Boolean;
    Comm     : Byte;
    RecNr    : Integer;
    Name     : String;
    Sex      : String[1];
    Answer   : Char;
    Tmp      : ObjRecord;
    Dum      : DataBase;
Begin
LogIn:=NoLogin;

Repeat
 Repeat
   My_ClrScr;

   ShowFile(HomeDir+'LOGO.MUD');
   My_WriteLn(HighLight+'MyMUD '+MudVersion+'/P '+CompileDate+LowLight);
   My_WriteLn('Type HELP for available options.');
   My_WriteLn('');

   Answer:=' ';
   My_Write('?> ');
   My_ReadLn(Name);
   Name:=CleanUp(Name);
   If Name[1]='?'
      Then Name:='HELP';
   Comm:=FindSpec(Name);
   Case Comm Of
     1 : Begin
         if ExistFile(WorldPath+'WORLD.INF')
            Then Begin
                 My_ClrScr;
                 ShowFile(WorldPath+'WORLD.INF');
                 End
            Else My_WriteLn('No info on this game available.');
         My_WriteLn('');
         My_WaitForKey('─── Press a key ───');
         Name:='';
         End;
     2 : Begin
         LogIn:=ShowWho;
         Exit;
         End;
     3 : Begin
         My_ClrScr;
         My_WriteLn('');
         My_WriteLn('  GAME - Info on this game');
         My_WriteLn('  HELP - this help');
         My_WriteLn('  INFO - Information about MyMUD');
         My_WriteLn('  QUIT - Abort the game.');
         My_WriteLn('  WHO  - Who''s logged in at this moment');
         My_WriteLn('  or your playername to log in.');
         My_WriteLn('');
         My_WaitForKey('─── Press a key ───');
         My_ClrScr;
         Name:='';
         End;
     4 : Begin
         LogIn:=AskedQuit;
         Exit;
         End;
     5 : Begin
         LogIn:=ShowVersion;
         Exit;
         End;
     Else Begin
          Current.Player:=Current.DB.FindPlayer(UpStr(Name));
          If (Current.Player=NOTHING)
             Then Begin
                  If My_YesNo('Did you write your name correct?','Y')='N'
                     Then Begin
                          Name:='';
                          End;
                  My_WriteLn('');
                  End;
          End;
   End; {Case}
 Until Name<>'';

 LogIn:=NormalLogin;
 If (Current.Player<>NOTHING) And
    IsAlive(Current.Player)
    Then Begin
         My_WriteLn('You''re already logged on. Please log out first!');
         Login:=ASKEDQuit;
         Exit;
         End;

 If Current.Player<>NOTHING
    Then Begin
         PassCount:=0;
         Repeat
          If UpStr(Name)<>'GUEST'
             Then Begin
                  My_Write('Password: ');
                  Password:=GetPassword;
                  If UpStr(Current.DB.ObjRec.Password)<>UpStr(Password)
                     Then Begin
                          My_WriteLn(' -- Illegal password.');
                          Inc(PassCount);
                          If PassCount>3
                             Then Halt(5);
                          End
                     Else PassCount:=0;
                  End;
         Until (PassCount=0);
         Current.PlayerName:=Current.DB.Name;
         Current.Room:=Current.DB.ObjRec.Location;
         Current.Note:='';
{*}      Current.DB.ObjRec.ObjType:=Player_Type;
{*}      Current.DB.UpdateObj(Current.Player);
         Exit;
         End;

 LogIn:=NewLogin;
 FillChar(Tmp,SizeOf(Tmp),#00);
 With Tmp Do
  Begin
  Contents  := NOTHING;
  Location  := 0;
  Next      := NOTHING;
  Pennies   := 5;
  ObjType   := Player_Type;
  Exits     :=0;
  Owner     :=NOTHING;
  Garbage   :=NOTHING;

  If UpStr(name)='GUEST'
     Then ObjLevel := Guest_Level
     Else ObjLevel := Player_Level;
  End; {With}

 Tmp.Name:=Name;
 My_WriteLn('Welcome new user!');
 My_WriteLn('');

 Repeat
  My_Write('Are you Male/Femal/Neuter/Quit? [M/F/N/Q]: ');
  My_ReadLn(Sex);
 Until Upcase(Sex[1]) in ['M','F','N','Q'];

 Case Upcase(Sex[1]) Of
  'N' : Tmp.Sex:=Ord(Neuter_Gender);
  'F' : Tmp.Sex:=Ord(Female_Gender);
  'M' : Tmp.Sex:=Ord(Male_Gender);
  'Q' : Begin
        LogIn:=AskedQUIT;
        Exit;
        End;
 End;

 Repeat
   My_Write('Give a password: ');
   Tmp.Password:=GetPassword;
   Tmp.Password:=CleanUp(Tmp.Password);
   My_WriteLn('');
   My_Write('Again: ');
   Ok:=(Tmp.Password<>'') And (Tmp.Password=CleanUp(GetPassword));
   My_WriteLn('');
 Until Ok;

 Lock('Adding new user');

 Current.DB.ObjRec:=Tmp;
 RecNr:=Current.DB.AddObj;
 Current.DB.ReadObj(RecNr);
 Current.DB.ObjRec.Owner:=RecNr;
 Dum.Init;
 Dum.ReadObj(0);
 Current.DB.ObjRec.Next:=Dum.ObjRec.Contents;
 Current.DB.ObjRec.Location:=0;
 Dum.ObjRec.Contents:=RecNr;
 Dum.UpdateObj(0);
 Current.DB.UpdateObj(RecNr);

 Current.PlayerName:=Tmp.Name;
 Current.Player:=RecNr;
 Current.Room:=0;

 Current.DB.AddPlayer(Current.Player);
 Dum.Final;

 Current.DB.Final;
 Current.DB.Init;

 UpdateNodeInfo(Current);
 Unlock;
 Exit;
Until False;
LogIn:=NewLogin;
End;


(*---------------------------------------------------------------------------*)
Procedure TranslateExpression(Current : ContextType;Var Expr : String);
Var NewLine : String;
    Temp    : String[40];
    ObjNr   : Integer;
    C       : Byte;
Begin
Expr:=Expr+' ';
NewLine:='';
Temp:='';
C:=1;
While C<=Length(Expr) Do
 Begin
 If (Expr[C] in ['A'..'Z','@']) And
    (C<=Length(Expr))
    Then Temp:=Temp+Expr[C]
    Else Begin
         If Temp<>''
            Then Begin
                 If Temp[1]='@'
                    Then Begin
                         NewLine:=NewLine+Temp;
                         Dec(C);
                         End
                    Else Begin
                         If Temp = 'ME'
                            Then ObjNr:=Current.Player
                            Else ObjNr:=Str2ObjNr(Current,Temp);
                         NewLine:=NewLine+Nr2Str(ObjNr)+Expr[C];
                         End;
                 temp:='';
                 End
            Else NewLine:=NewLine+Expr[C];
         End;
 Inc(C);
 End; {While}
Expr:=NewLine;
End;

(*--------------------------------------------------------------------------*)
Procedure Generate_Pennies(Current : ContextType);
Var OldRec : ObjRecord;

Begin
Lock('Found penny');
Current.DB.ReadObj(Current.Room);
OldRec:=Current.DB.ObjRec;
Current.DB.ReadObj(Current.Player);
If (Not (Current.DB.LevelOk(Wizard_Level) Or (OldRec.Owner=Current.Player))) And
   (Current.DB.ObjRec.Pennies<=MAX_PENNIES) And
   (Random(PENNY_RATE)=0)
   Then Begin
        My_WriteLn('You found a penny!');
        Inc(Current.DB.ObjRec.Pennies);
        Current.DB.UpdateObj(Current.Player);

        End;
Unlock;
End;

End.